home *** CD-ROM | disk | FTP | other *** search
/ Mac Easy 2010 May / Mac Life Ubuntu.iso / casper / filesystem.squashfs / usr / share / guile / 1.8 / oop / goops / compile.scm < prev    next >
Encoding:
Text File  |  2008-12-17  |  4.5 KB  |  140 lines
  1. ;;;;     Copyright (C) 1999, 2001, 2006 Free Software Foundation, Inc.
  2. ;;;; 
  3. ;;;; This library is free software; you can redistribute it and/or
  4. ;;;; modify it under the terms of the GNU Lesser General Public
  5. ;;;; License as published by the Free Software Foundation; either
  6. ;;;; version 2.1 of the License, or (at your option) any later version.
  7. ;;;; 
  8. ;;;; This library is distributed in the hope that it will be useful,
  9. ;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. ;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11. ;;;; Lesser General Public License for more details.
  12. ;;;; 
  13. ;;;; You should have received a copy of the GNU Lesser General Public
  14. ;;;; License along with this library; if not, write to the Free Software
  15. ;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16. ;;;; 
  17.  
  18.  
  19. (define-module (oop goops compile)
  20.   :use-module (oop goops)
  21.   :use-module (oop goops util)
  22.   :export (compute-cmethod compute-entry-with-cmethod
  23.        compile-method cmethod-code cmethod-environment)
  24.   :no-backtrace
  25.   )
  26.  
  27. (define source-formals cadr)
  28. (define source-body cddr)
  29.  
  30. (define cmethod-code cdr)
  31. (define cmethod-environment car)
  32.  
  33.  
  34. ;;;
  35. ;;; Method entries
  36. ;;;
  37.  
  38. (define code-table-lookup
  39.   (letrec ((check-entry (lambda (entry types)
  40.               (if (null? types)
  41.                   (and (not (struct? (car entry)))
  42.                    entry)
  43.                   (and (eq? (car entry) (car types))
  44.                    (check-entry (cdr entry) (cdr types)))))))
  45.     (lambda (code-table types)
  46.       (cond ((null? code-table) #f)
  47.         ((check-entry (car code-table) types)
  48.          => (lambda (cmethod)
  49.           (cons (car code-table) cmethod)))
  50.         (else (code-table-lookup (cdr code-table) types))))))
  51.  
  52. (define (compute-entry-with-cmethod methods types)
  53.   (or (code-table-lookup (slot-ref (car methods) 'code-table) types)
  54.       (let* ((method (car methods))
  55.          (place-holder (list #f))
  56.          (entry (append types place-holder)))
  57.     ;; In order to handle recursion nicely, put the entry
  58.     ;; into the code-table before compiling the method 
  59.     (slot-set! (car methods) 'code-table
  60.            (cons entry (slot-ref (car methods) 'code-table)))
  61.     (let ((cmethod (compile-method methods types)))
  62.       (set-car! place-holder (car cmethod))
  63.       (set-cdr! place-holder (cdr cmethod)))
  64.     (cons entry place-holder))))
  65.  
  66. (define (compute-cmethod methods types)
  67.   (cdr (compute-entry-with-cmethod methods types)))
  68.  
  69. ;;;
  70. ;;; Next methods
  71. ;;;
  72.  
  73. ;;; Temporary solution---return #f if x doesn't refer to `next-method'.
  74. (define (next-method? x)
  75.   (and (pair? x)
  76.        (or (eq? (car x) 'next-method)
  77.        (next-method? (car x))
  78.        (next-method? (cdr x)))))
  79.  
  80. (define (make-final-make-next-method method)
  81.   (lambda default-args
  82.     (lambda args
  83.       (@apply method (if (null? args) default-args args)))))      
  84.  
  85. (define (make-final-make-no-next-method gf)
  86.   (lambda default-args
  87.     (lambda args
  88.       (no-next-method gf (if (null? args) default-args args)))))
  89.  
  90. (define (make-make-next-method vcell gf methods types)
  91.   (lambda default-args
  92.     (lambda args
  93.       (if (null? methods)
  94.       (begin
  95.         (set-cdr! vcell (make-final-make-no-next-method gf))
  96.         (no-next-method gf (if (null? args) default-args args)))
  97.       (let* ((cmethod (compute-cmethod methods types))
  98.          (method (local-eval (cons 'lambda (cmethod-code cmethod))
  99.                      (cmethod-environment cmethod))))
  100.         (set-cdr! vcell (make-final-make-next-method method))
  101.         (@apply method (if (null? args) default-args args)))))))
  102.  
  103. ;;;
  104. ;;; Method compilation
  105. ;;;
  106.  
  107. ;;; NOTE: This section is far from finished.  It will finally be
  108. ;;; implemented on C level.
  109.  
  110. (define %tag-body
  111.   (nested-ref the-root-module '(app modules oop goops %tag-body)))
  112.  
  113. (define (compile-method methods types)
  114.   (let* ((proc (method-procedure (car methods)))
  115.      ;; XXX - procedure-source can not be guaranteed to be
  116.      ;;       reliable or efficient
  117.      (src (procedure-source proc)) 
  118.      (formals (source-formals src))
  119.      (body (source-body src)))
  120.     (if (next-method? body)
  121.     (let ((vcell (cons 'goops:make-next-method #f)))
  122.       (set-cdr! vcell
  123.             (make-make-next-method
  124.              vcell
  125.              (method-generic-function (car methods))
  126.              (cdr methods) types))
  127.       ;;*fixme*
  128.       `(,(cons vcell (procedure-environment proc))
  129.         ,formals
  130.         ;;*fixme* Only do this on source where next-method can't be inlined
  131.         (let ((next-method ,(if (list? formals)
  132.                     `(goops:make-next-method ,@formals)
  133.                     `(apply goops:make-next-method
  134.                         ,@(improper->proper formals)))))
  135.           ,@body)))
  136.     (cons (procedure-environment proc)
  137.           (cons formals
  138.             (%tag-body body)))
  139.     )))
  140.